home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 051-075 / disk_054 / ispell / ispell.el < prev    next >
Lisp/Scheme  |  1992-05-06  |  10KB  |  274 lines
  1. ;;; Spelling correction interface for GNU EMACS using "ispell"
  2.  
  3. ;;; Walt Buehring
  4. ;;; Texas Instruments - Computer Science Center
  5. ;;; ARPA:  Buehring%TI-CSL@CSNet-Relay
  6. ;;; UUCP:  {smu, texsun, im4u, rice} ! ti-csl ! buehring
  7.  
  8. ;;; ispell-region and associate routines added by
  9. ;;; Perry Smith
  10. ;;; pedz@bobkat
  11. ;;; Tue Jan 13 20:18:02 CST 1987
  12.  
  13. ;;; Depends on the ispell program snarfed from MIT-PREP in early 
  14. ;;; 1986.  The only interactive command is "ispell-word" which should be
  15. ;;; bound to M-$.  If someone writes an "ispell-region" command, 
  16. ;;; I would appreciate a copy.
  17.  
  18. ;;; To fully install this, add this file to your GNU lisp directory and 
  19. ;;; compile it with M-X byte-compile-file.  Then add the following to the
  20. ;;; appropriate init file:
  21.  
  22. ;;;  (autoload 'ispell-word "ispell"
  23. ;;;    "Check the spelling of word in buffer." t)
  24. ;;;  (global-set-key "\e$" 'ispell-word)
  25.  
  26. ;;; If run on a heavily loaded system, the timeout value in ispell-check 
  27. ;;; and the initial sleep time in ispell-init-process may need to be increased.
  28.  
  29. ;;; No warranty expressed or implied.  All sales final.  Void where prohibited.
  30. ;;; If you don't like it, change it.
  31.  
  32. (defvar ispell-syntax-table nil)
  33.  
  34. (if (null ispell-syntax-table)
  35.     ;; The following assumes that the standard-syntax-table
  36.     ;; is static.  If you add words with funky characters
  37.     ;; to your dictionary, the following may have to change.
  38.     (progn
  39.       (setq ispell-syntax-table (make-syntax-table))
  40.       ;; Make certain characters word constituents
  41.       ;; (modify-syntax-entry ?' "w   " ispell-syntax-table)
  42.       ;; (modify-syntax-entry ?- "w   " ispell-syntax-table)
  43.       ;; Get rid on existing word syntax on certain characters 
  44.       (modify-syntax-entry ?0 ".   " ispell-syntax-table)
  45.       (modify-syntax-entry ?1 ".   " ispell-syntax-table)
  46.       (modify-syntax-entry ?2 ".   " ispell-syntax-table)
  47.       (modify-syntax-entry ?3 ".   " ispell-syntax-table)
  48.       (modify-syntax-entry ?4 ".   " ispell-syntax-table)
  49.       (modify-syntax-entry ?5 ".   " ispell-syntax-table)
  50.       (modify-syntax-entry ?6 ".   " ispell-syntax-table)
  51.       (modify-syntax-entry ?7 ".   " ispell-syntax-table)
  52.       (modify-syntax-entry ?8 ".   " ispell-syntax-table)
  53.       (modify-syntax-entry ?9 ".   " ispell-syntax-table)
  54.       (modify-syntax-entry ?$ ".   " ispell-syntax-table)
  55.       (modify-syntax-entry ?% ".   " ispell-syntax-table)))
  56.  
  57.  
  58. (defun ispell-word (&optional quietly)
  59.   "Check spelling of word at or before dot.
  60. If word not found in dictionary, display possible corrections in a window 
  61. and let user select."
  62.   (interactive)
  63.   (let* ((current-syntax (syntax-table))
  64.      start end word poss replace)
  65.     (unwind-protect
  66.     (save-excursion
  67.       ;; Ensure syntax table is reasonable 
  68.       (set-syntax-table ispell-syntax-table)
  69.       ;; Move backward for word if not already on one.
  70.       (if (not (looking-at "\\w"))
  71.           (re-search-backward "\\w" (dot-min) 'stay))
  72.       ;; Move to start of word
  73.       (re-search-backward "\\W" (dot-min) 'stay)
  74.       ;; Find start and end of word
  75.       (or (re-search-forward "\\w+" nil t)
  76.           (error "No word to check."))
  77.       (setq start (match-beginning 0)
  78.         end (match-end 0)
  79.         word (buffer-substring start end)))
  80.       (set-syntax-table current-syntax))
  81.     (or quietly (message "Checking spelling of %s..." (upcase word)))
  82.     (setq poss (ispell-check word))
  83.     (cond ((eq poss t)
  84.        (or quietly (message "Found %s" (upcase word))))
  85.       ((stringp poss)
  86.        (or quietly (message "Found it because of %s" (upcase poss))))
  87.       ((null poss)
  88.        (or quietly (message "Could Not Find %s" (upcase word))))
  89.       (t (setq replace (ispell-choose poss word))
  90.          (if replace
  91.          (progn
  92.             (goto-char end)
  93.             (delete-region start end)
  94.             (insert-string replace)))))
  95.     poss))
  96.  
  97.  
  98. (defun ispell-choose (choices word)
  99.   "Display possible corrections from list CHOICES.  Return chosen word
  100. if one is chosen; Return nil to keep word"
  101.   (unwind-protect 
  102.       (save-window-excursion
  103.     (let ((count 0)
  104.           (words choices)
  105.           (window-min-height 2)
  106.           char num result)
  107.       (overlay-window 3)
  108.       (switch-to-buffer "*Choices*") (erase-buffer)
  109.       (setq mode-line-format "--  %b  --")
  110.       (while words
  111.         (if (> (+ 7 (current-column) (length (car words))) (window-width))
  112.         (insert "\n"))
  113.         (insert "(" (+ count ?1) ") " (car words) "  ")
  114.         (setq words (cdr words)
  115.           count (1+ count)))
  116.       (select-window (next-window))
  117.       (while (eq t
  118.              (setq result
  119.                (progn
  120.                  (message "Enter letter to replace word;  Space to flush")
  121.                  (setq char (upcase (read-char)))
  122.                  (setq num (- char ?1))
  123.                  (cond ((= char ? ) nil)
  124.                    ((= char ?I)
  125.                     (ispell-check (concat "*" word))
  126.                     nil)
  127.                    ((= char ?A)
  128.                     (ispell-check (concat "@" word))
  129.                     nil)
  130.                    ((= char ?R) (read-string "Replacement: " nil))
  131.                    ((and (>= num 0) (< num count)) (nth num choices))
  132.                    (t (ding) t))))))
  133.       result))
  134.     ;; Protected forms...
  135.     (bury-buffer "*Choices*")))
  136.  
  137.  
  138. (defun overlay-window (height)
  139.   "Create a (usually small) window with HEIGHT lines and avoid
  140. recentering."
  141.   (save-excursion
  142.     (let ((oldot (save-excursion (beginning-of-line) (dot)))
  143.       (top (save-excursion (move-to-window-line height) (dot)))
  144.       newin)
  145.       (if (< oldot top) (setq top oldot))
  146.       (setq newin (split-window-vertically height))
  147.       (set-window-start newin top))))
  148.  
  149.  
  150. (defvar ispell-process nil
  151.   "Holds the process object for 'ispell'")
  152.  
  153. ;;; create signal used by ispell-filter and ispell-check
  154. (put 'ispell-output 'error-conditions '(ispell-output))
  155.  
  156. (defun ispell-check (word)
  157. "Check spelling of string WORD, return either t for an exact match, a string
  158. containing the root word for a match via suffix removal, a list of possible 
  159. correct spellings, or nil for a complete miss."
  160.   (ispell-init-process)
  161.   (send-string ispell-process (concat word "\n"))
  162.   (condition-case output
  163.       (progn
  164.     (sleep-for 20)
  165.     (error "Timeout waiting for ispell process output"))
  166.     (ispell-output (ispell-parse-output (car (cdr output))))))
  167.  
  168. (defun ispell-parse-output (output)
  169. "Parse the OUTPUT string of 'ispell' and return a value as specified by the 
  170. 'ispell-check' function."
  171.   (cond
  172.    ((string= output "*") t)
  173.    ((string= output "#") nil)
  174.    ((string= (substring output 0 1) "+")
  175.     (substring output 2))
  176.    (t
  177.     (let ((choice-list '()))
  178.       (while (not (string= output ""))
  179.     (let* ((start (string-match "[A-z]" output))
  180.            (end (string-match " \\|$" output start)))
  181.       (if start
  182.           (setq choice-list (cons (substring output start end)
  183.                       choice-list)))
  184.       (setq output (substring output (1+ end)))))
  185.       choice-list))))
  186.  
  187.  
  188. (defvar ispell-process-output ""
  189.   "Holds partial output from the 'ispell' process")
  190.  
  191. (defun ispell-filter (process output)
  192.   "The filter-function for 'ispell'.  Signals complete line using the 
  193. ispell-output signal"
  194.   (if (string= "\n" (substring output (1- (length output))))
  195.       (progn
  196.     (setq output (concat ispell-process-output
  197.                  (substring output 0 (1- (length output))))
  198.           ispell-process-output "")
  199.     (signal 'ispell-output (list output)))
  200.       (setq ispell-process-output (concat ispell-process-output output))))
  201.  
  202. (defun ispell-init-process ()
  203.   "Check status of 'ispell' process and start if necessary; set up 
  204. filter function for output."
  205.   (if (or (not ispell-process)
  206.       (not (eq (process-status ispell-process) 'run)))
  207.       (progn
  208.     (message "Starting new ispell process...")
  209.     (and (get-buffer "*ispell*") (kill-buffer "*ispell*"))
  210.     (setq ispell-process (start-process "ispell" "*ispell*"
  211.                        "ispell" "-a"))
  212.     (set-process-filter ispell-process 'ispell-filter)
  213.     (process-kill-without-query ispell-process)
  214.     (sit-for 3))))
  215.  
  216. (defvar ispell-filter-hook "/bin/cat"
  217.   "Filter to pass a region through before sending it to ispell.
  218. Typically this is set to cat, deroff, detex, etc.")
  219. (make-variable-buffer-local 'ispell-filter-hook)
  220.  
  221. (defvar ispell-filter-hook-args nil
  222.   "Arguments to pass to ispell-filter-hook")
  223. (make-variable-buffer-local 'ispell-filter-hook-args)
  224.  
  225. ; This routine has certain limitations brought about by the filter
  226. ; hook.  For example, deroff will take ``\fBcat\fR'' and spit out
  227. ; ``cat''.  This is hard to search for since word-search-forward will
  228. ; not match at all and search-forward for ``cat'' will match
  229. ; ``concatinate'' if it happens to occur before.  I attempt to
  230. ; minimize these problems by always searching for each word in the
  231. ; original buffer even if it is not misspelled.  This slows things
  232. ; down.
  233.  
  234. (defun ispell-region (start end)
  235.   "Check a region for spelling errors interactively.  The variable
  236. which should be buffer or mode specific ispell-filter-hook is called
  237. to filter out text processing commands."
  238.   (interactive "r")
  239.   (let ((this-buf (current-buffer))
  240.     (spell-buf (get-buffer-create "ispell-temp"))
  241.     (current-syntax (syntax-table))
  242.     word poss replace word-start word-end)
  243.     (unwind-protect
  244.     (save-excursion
  245.       (set-buffer spell-buf)
  246.       (erase-buffer)
  247.       (set-buffer this-buf)
  248.       (if ispell-filter-hook-args
  249.           (call-process-region start end ispell-filter-hook nil
  250.                    spell-buf nil ispell-filter-hook-args)
  251.         (call-process-region start end ispell-filter-hook nil
  252.                  spell-buf nil))
  253.       (goto-char start)
  254.       (set-buffer spell-buf)
  255.       (set-syntax-table ispell-syntax-table)
  256.       (goto-char (point-min))
  257.       (while (progn
  258.            (message "Looking for a misspelled word")
  259.            (re-search-forward "\\W*\\(\\w+\\)" nil t))
  260.         (setq word (buffer-substring (setq word-start (match-beginning 1))
  261.                      (setq word-end (match-end 1))))
  262.         (setq poss (ispell-check word))
  263.         (set-buffer this-buf)
  264.         (or (search-forward word nil t)
  265.         (error "Can not find %s in original text" word))
  266.         (if (not (or (eq poss t) (stringp poss))) ;bad word
  267.         (progn
  268.           (sit-for 0)
  269.           (setq replace (ispell-choose poss word))
  270.           (if replace
  271.               (replace-match replace))))
  272.         (set-buffer spell-buf)))
  273.       (set-syntax-table current-syntax))))
  274.